home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / libs / vesatp11 / example / bgidemo.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-03-21  |  40.8 KB  |  1,522 lines
  1.  
  2. { Turbo Graphics }
  3. { Copyright (c) 1985, 1990 by Borland International, Inc. }
  4.  
  5. program BGIDemo;
  6. (*
  7.   Turbo Pascal 6.0 Borland Graphics Interface (BGI) demonstration
  8.   program. This program shows how to use many features of
  9.   the Graph unit.
  10.  
  11.   NOTE: to have this demo use the IBM8514 driver, specify a
  12.   conditional define constant "Use8514" (using the {$DEFINE}
  13.   directive or Options\Compiler\Conditional defines) and then
  14.   re-compile.
  15.  
  16. *)
  17.  
  18. {
  19.     Changes:
  20.    ( '->' means 'replaced by' )
  21.    - Graph             -> VGraph,Vesa
  22.    - InitGraph     -> InitVesa
  23.    - CloseGraph     -> CloseVesa
  24.    - Palette.Size -> 16
  25.    - PutImage         ->
  26.    - GetMaxColor     -> 15;
  27.  
  28.    Added:
  29.    Procedure SelectMode;
  30.    VAR mode : WORD;
  31. }
  32.  
  33. uses
  34.   Crt, Dos, VGraph, Vesa;
  35.  
  36.  
  37. const
  38.   { The five fonts available }
  39.   Fonts : array[0..4] of string[13] =
  40.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  41.  
  42.   { The five predefined line styles supported }
  43.   LineStyles : array[0..4] of string[9] =
  44.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  45.  
  46.   { The twelve predefined fill styles supported }
  47.   FillStyles : array[0..11] of string[14] =
  48.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  49.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  50.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  51.  
  52.   { The two text directions available }
  53.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  54.  
  55.   { The Horizontal text justifications available }
  56.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  57.  
  58.   { The vertical text justifications available }
  59.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  60.  
  61. var
  62.   GraphDriver : integer;  { The Graphics device driver }
  63.   GraphMode   : integer;  { The Graphics mode value }
  64.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  65.   ErrorCode   : integer;  { Reports any graphics errors }
  66.   MaxColor    : word;     { The maximum color value available }
  67.   OldExitProc : Pointer;  { Saves exit procedure address }
  68.   mode            : WORD;
  69.  
  70. {$F+}
  71. procedure MyExitProc;
  72. begin
  73.   ExitProc := OldExitProc; { Restore exit procedure address }
  74. {  CloseGraph;              { Shut down the graphics system }
  75.   CloseVesa;
  76. end; { MyExitProc }
  77. {$F-}
  78.  
  79. procedure Initialize;
  80. { Initialize graphics and report any errors that may occur }
  81. var
  82.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  83.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  84. begin
  85.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  86.   DirectVideo := False;
  87.   OldExitProc := ExitProc;                { save previous exit proc }
  88.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  89.   PathToDriver := '';
  90.   repeat
  91.  
  92. {$IFDEF Use8514}                          { check for Use8514 $DEFINE }
  93.     GraphDriver := IBM8514;
  94.     GraphMode := IBM8514Hi;
  95. {$ELSE}
  96.     GraphDriver := Detect;                { use autodetection }
  97. {$ENDIF}
  98.  
  99. {     InitGraph(GraphDriver, GraphMode, PathToDriver); }
  100.      InitVesa(mode);
  101.      ErrorCode := GraphResult;             { preserve error return }
  102.     if ErrorCode <> grOK then             { error? }
  103.     begin
  104.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  105.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  106.       begin
  107.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  108.         Readln(PathToDriver);
  109.         Writeln;
  110.       end
  111.       else
  112.         Halt(1);                          { Some other error: terminate }
  113.      end;
  114.   until ErrorCode = grOK;
  115.   Randomize;                { init random number generator }
  116.   MaxColor := 15;               { Get the maximum allowable drawing color }
  117.   MaxX := GetMaxX;          { Get screen resolution values }
  118.   MaxY := GetMaxY;
  119. end; { Initialize }
  120.  
  121. function Int2Str(L : LongInt) : string;
  122. { Converts an integer to a string for use with OutText, OutTextXY }
  123. var
  124.   S : string;
  125. begin
  126.   Str(L, S);
  127.   Int2Str := S;
  128. end; { Int2Str }
  129.  
  130. function RandColor : word;
  131. { Returns a Random non-zero color value that is within the legal
  132.   color range for the selected device driver and graphics mode.
  133.   MaxColor is set to GetMaxColor by Initialize }
  134. begin
  135.   RandColor := Random(MaxColor)+1;
  136. end; { RandColor }
  137.  
  138. procedure DefaultColors;
  139. { Select the maximum color in the Palette for the drawing color }
  140. begin
  141.   SetColor(MaxColor);
  142. end; { DefaultColors }
  143.  
  144. procedure DrawBorder;
  145. { Draw a border around the current view port }
  146. var
  147.   ViewPort : ViewPortType;
  148. begin
  149.   DefaultColors;
  150.   SetLineStyle(SolidLn, 0, NormWidth);
  151.   GetViewSettings(ViewPort);
  152.   with ViewPort do
  153.     Rectangle(0, 0, x2-x1, y2-y1);
  154. end; { DrawBorder }
  155.  
  156. procedure FullPort;
  157. { Set the view port to the entire screen }
  158. begin
  159.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  160. end; { FullPort }
  161.  
  162. procedure MainWindow(Header : string);
  163. { Make a default window and view port for demos }
  164. begin
  165.   DefaultColors;                           { Reset the colors }
  166.   ClearDevice;                             { Clear the screen }
  167.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  168.   SetTextJustify(CenterText, TopText);     { Left justify text }
  169.   FullPort;                                { Full screen view port }
  170.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  171.   { Draw main window }
  172.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  173.   DrawBorder;                              { Put a border around it }
  174.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  175.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  176. end; { MainWindow }
  177.  
  178. procedure StatusLine(Msg : string);
  179. { Display a status line at the bottom of the screen }
  180. begin
  181.   FullPort;
  182.   DefaultColors;
  183.   SetTextStyle(DefaultFont, HorizDir, 1);
  184.   SetTextJustify(CenterText, TopText);
  185.   SetLineStyle(SolidLn, 0, NormWidth);
  186.   SetFillStyle(EmptyFill, 0);
  187.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  188.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  189.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  190.   { Go back to the main window }
  191.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  192. end; { StatusLine }
  193.  
  194. procedure WaitToGo;
  195. { Wait for the user to abort the program or continue }
  196. const
  197.   Esc = #27;
  198. var
  199.   Ch : char;
  200. begin
  201.   StatusLine('Esc aborts or press a key...');
  202.   repeat until KeyPressed;
  203.   Ch := ReadKey;
  204.   if ch = #0 then ch := readkey;      { trap function keys }
  205.   if Ch = Esc then
  206.     Halt(0)                           { terminate program }
  207.   else
  208.     ClearDevice;                      { clear screen, go on with demo }
  209. end; { WaitToGo }
  210.  
  211. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  212. { Return strings describing the current device driver and graphics mode
  213.   for display of status report }
  214. begin
  215.   DriveStr := GetDriverName;
  216.   ModeStr := GetModeName(GetGraphMode);
  217. end; { GetDriverAndMode }
  218.  
  219. procedure ReportStatus;
  220. { Display the status of all query functions after InitGraph }
  221. const
  222.   X = 10;
  223. var
  224.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  225.   LineInfo   : LineSettingsType;
  226.   FillInfo   : FillSettingsType;
  227.   TextInfo   : TextSettingsType;
  228.   Palette    : PaletteType;
  229.   DriverStr  : string;           { Driver and mode strings }
  230.   ModeStr    : string;
  231.   Y          : word;
  232.  
  233. procedure WriteOut(S : string);
  234. { Write out a string and increment to next line }
  235. begin
  236.   OutTextXY(X, Y, S);
  237.   Inc(Y, TextHeight('M')+2);
  238. end; { WriteOut }
  239.  
  240. begin { ReportStatus }
  241.   GetDriverAndMode(DriverStr, ModeStr);   { Get current settings }
  242.   GetViewSettings(ViewInfo);
  243.   GetLineSettings(LineInfo);
  244.   GetFillSettings(FillInfo);
  245.   GetTextSettings(TextInfo);
  246.   GetPalette(Palette);
  247.  
  248.   Y := 4;
  249.   MainWindow('Status report after InitGraph');
  250.   SetTextJustify(LeftText, TopText);
  251.   WriteOut('Graphics device    : '+DriverStr);
  252.   WriteOut('Graphics mode      : '+ModeStr);
  253.   WriteOut('Screen resolution  : (0, 0, '+Int2Str(GetMaxX)+', '+Int2Str(GetMaxY)+')');
  254.   with ViewInfo do
  255.   begin
  256.     WriteOut('Current view port  : ('+Int2Str(x1)+', '+Int2Str(y1)+', '+Int2Str(x2)+', '+Int2Str(y2)+')');
  257.     if ClipOn then
  258.       WriteOut('Clipping           : ON')
  259.     else
  260.       WriteOut('Clipping           : OFF');
  261.   end;
  262.   WriteOut('Current position   : ('+Int2Str(GetX)+', '+Int2Str(GetY)+')');
  263.   WriteOut('Palette entries    : '+Int2Str(16));
  264.   WriteOut('GetMaxColor        : '+Int2Str(GetMaxColor));
  265.   WriteOut('Current color      : '+Int2Str(GetColor));
  266.   with LineInfo do
  267.   begin
  268.     WriteOut('Line style         : '+LineStyles[LineStyle]);
  269.     WriteOut('Line thickness     : '+Int2Str(Thickness));
  270.   end;
  271.   with FillInfo do
  272.   begin
  273.     WriteOut('Current fill style : '+FillStyles[Pattern]);
  274.     WriteOut('Current fill color : '+Int2Str(Color));
  275.   end;
  276.   with TextInfo do
  277.   begin
  278.     WriteOut('Current font       : '+Fonts[Font]);
  279.     WriteOut('Text direction     : '+TextDirect[Direction]);
  280.     WriteOut('Character size     : '+Int2Str(CharSize));
  281.     WriteOut('Horizontal justify : '+HorizJust[Horiz]);
  282.     WriteOut('Vertical justify   : '+VertJust[Vert]);
  283.   end;
  284.   WaitToGo;
  285. end; { ReportStatus }
  286.  
  287. procedure FillEllipsePlay;
  288. { Random filled ellipse demonstration }
  289. const
  290.   MaxFillStyles = 12; { patterns 0..11 }
  291. var
  292.   MaxRadius : word;
  293.   FillColor : integer;
  294. begin
  295.   MainWindow('FillEllipse demonstration');
  296.   StatusLine('Esc aborts or press a key');
  297.   MaxRadius := MaxY div 10;
  298.   SetLineStyle(SolidLn, 0, NormWidth);
  299.   repeat
  300.     FillColor := RandColor;
  301.     SetColor(FillColor);
  302.     SetFillStyle(Random(MaxFillStyles), FillColor);
  303.     FillEllipse(Random(MaxX), Random(MaxY),
  304.                 Random(MaxRadius), Random(MaxRadius));
  305.   until KeyPressed;
  306.   WaitToGo;
  307. end; { FillEllipsePlay }
  308.  
  309. procedure SectorPlay;
  310. { Draw random sectors on the screen }
  311. const
  312.   MaxFillStyles = 12; { patterns 0..11 }
  313. var
  314.   MaxRadius : word;
  315.   FillColor : integer;
  316.   EndAngle  : integer;
  317. begin
  318.   MainWindow('Sector demonstration');
  319.   StatusLine('Esc aborts or press a key');
  320.   MaxRadius := MaxY div 10;
  321.   SetLineStyle(SolidLn, 0, NormWidth);
  322.   repeat
  323.     FillColor := RandColor;
  324.     SetColor(FillColor);
  325.     SetFillStyle(Random(MaxFillStyles), FillColor);
  326.     EndAngle := Random(360);
  327.     Sector(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle,
  328.            Random(MaxRadius), Random(MaxRadius));
  329.   until KeyPressed;
  330.   WaitToGo;
  331. end; { SectorPlay }
  332.  
  333. procedure WriteModePlay;
  334. { Demonstrate the SetWriteMode procedure for XOR lines }
  335. const
  336.   DelayValue = 50;  { milliseconds to delay }
  337. var
  338.   ViewInfo      : ViewPortType;
  339.   Color         : word;
  340.   Left, Top     : integer;
  341.   Right, Bottom : integer;
  342.   Step          : integer; { step for rectangle shrinking }
  343. begin
  344.   MainWindow('SetWriteMode demonstration');
  345.   StatusLine('Esc aborts or press a key');
  346.   GetViewSettings(ViewInfo);
  347.   Left := 0;
  348.   Top := 0;
  349.   with ViewInfo do
  350.   begin
  351.     Right := x2-x1;
  352.     Bottom := y2-y1;
  353.   end;
  354.   Step := Bottom div 50;
  355.   SetColor(15);
  356.   Line(Left, Top, Right, Bottom);
  357.   Line(Left, Bottom, Right, Top);
  358.   SetWriteMode(XORPut);                    { Set XOR write mode }
  359.   repeat
  360.     Line(Left, Top, Right, Bottom);        { Draw XOR lines }
  361.     Line(Left, Bottom, Right, Top);
  362.     Rectangle(Left, Top, Right, Bottom);   { Draw XOR rectangle }
  363.     Delay(DelayValue);                     { Wait }
  364.     Line(Left, Top, Right, Bottom);        { Erase lines }
  365.     Line(Left, Bottom, Right, Top);
  366.     Rectangle(Left, Top, Right, Bottom);   { Erase rectangle }
  367.     if (Left+Step < Right) and (Top+Step < Bottom) then
  368.       begin
  369.         Inc(Left, Step);                  { Shrink rectangle }
  370.         Inc(Top, Step);
  371.         Dec(Right, Step);
  372.         Dec(Bottom, Step);
  373.       end
  374.     else
  375.       begin
  376.         Color := RandColor;                { New color }
  377.         SetColor(Color);
  378.         Left := 0;                         { Original large rectangle }
  379.         Top := 0;
  380.         with ViewInfo do
  381.         begin
  382.           Right := x2-x1;
  383.           Bottom := y2-y1;
  384.         end;
  385.       end;
  386.   until KeyPressed;
  387.   SetWriteMode(CopyPut);                   { back to overwrite mode }
  388.   WaitToGo;
  389. end; { WriteModePlay }
  390.  
  391. procedure AspectRatioPlay;
  392. { Demonstrate  SetAspectRatio command }
  393. var
  394.   ViewInfo   : ViewPortType;
  395.   CenterX    : integer;
  396.   CenterY    : integer;
  397.   Radius     : word;
  398.   Xasp, Yasp : word;
  399.   i          : integer;
  400.   RadiusStep : word;
  401. begin
  402.   MainWindow('SetAspectRatio demonstration');
  403.   GetViewSettings(ViewInfo);
  404.   with ViewInfo do
  405.   begin
  406.     CenterX := (x2-x1) div 2;
  407.     CenterY := (y2-y1) div 2;
  408.     Radius := 3*((y2-y1) div 5);
  409.   end;
  410.   RadiusStep := (Radius div 30);
  411.   Circle(CenterX, CenterY, Radius);
  412.   GetAspectRatio(Xasp, Yasp);
  413.   for i := 1 to 30 do
  414.   begin
  415.     SetAspectRatio(Xasp, Yasp+(I*GetMaxX));    { Increase Y aspect factor }
  416.     Circle(CenterX, CenterY, Radius);
  417.     Dec(Radius, RadiusStep);                   { Shrink radius }
  418.   end;
  419.   Inc(Radius, RadiusStep*30);
  420.   for i := 1 to 30 do
  421.   begin
  422.     SetAspectRatio(Xasp+(I*GetMaxX), Yasp);    { Increase X aspect factor }
  423.     if Radius > RadiusStep then
  424.       Dec(Radius, RadiusStep);                 { Shrink radius }
  425.     Circle(CenterX, CenterY, Radius);
  426.   end;
  427.   SetAspectRatio(Xasp, Yasp);                  { back to original aspect }
  428.   WaitToGo;
  429. end; { AspectRatioPlay }
  430.  
  431. procedure TextPlay;
  432. { Demonstrate text justifications and text sizing }
  433. var
  434.   Size : word;
  435.   W, H, X, Y : word;
  436.   ViewInfo : ViewPortType;
  437. begin
  438.   MainWindow('SetTextJustify / SetUserCharSize demo');
  439.   GetViewSettings(ViewInfo);
  440.   with ViewInfo do
  441.   begin
  442.     SetTextStyle(TriplexFont, VertDir, 4);
  443.     Y := (y2-y1) - 2;
  444.     SetTextJustify(CenterText, BottomText);
  445.     OutTextXY(2*TextWidth('M'), Y, 'Vertical');
  446.     SetTextStyle(TriplexFont, HorizDir, 4);
  447.     SetTextJustify(LeftText, TopText);
  448.     OutTextXY(2*TextWidth('M'), 2, 'Horizontal');
  449.     SetTextJustify(CenterText, CenterText);
  450.     X := (x2-x1) div 2;
  451.     Y := TextHeight('H');
  452.     for Size := 1 to 4 do
  453.     begin
  454.       SetTextStyle(TriplexFont, HorizDir, Size);
  455.       H := TextHeight('M');
  456.       W := TextWidth('M');
  457.       Inc(Y, H);
  458.       OutTextXY(X, Y, 'Size '+Int2Str(Size));
  459.     end;
  460.     Inc(Y, H div 2);
  461.     SetTextJustify(CenterText, TopText);
  462.      SetUserCharSize(5, 6, 3, 2);
  463.      SetTextStyle(TriplexFont, HorizDir, UserCharSize);
  464.     OutTextXY((x2-x1) div 2, Y, 'User defined size!');
  465.   end;
  466.   WaitToGo;
  467. end; { TextPlay }
  468.  
  469. procedure TextDump;
  470. { Dump the complete character sets to the screen }
  471. const
  472.   CGASizes  : array[0..4] of word = (1, 3, 7, 3, 3);
  473.   NormSizes : array[0..4] of word = (1, 4, 7, 4, 4);
  474. var
  475.   Font : word;
  476.   ViewInfo : ViewPortType;
  477.   Ch : char;
  478. begin
  479.   for Font := 0 to 4 do
  480.   begin
  481.     MainWindow(Fonts[Font]+' character set');
  482.     GetViewSettings(ViewInfo);
  483.     with ViewInfo do
  484.     begin
  485.       SetTextJustify(LeftText, TopText);
  486.       MoveTo(2, 3);
  487.       if Font = DefaultFont then
  488.         begin
  489.           SetTextStyle(Font, HorizDir, 1);
  490.           Ch := #0;
  491.           repeat
  492.                 OutText(Ch);
  493.                 if (GetX + TextWidth('M')) > (x2-x1) then
  494.               MoveTo(2, GetY + TextHeight('M')+3);
  495.             Ch := Succ(Ch);
  496.           until (Ch >= #255);
  497.         end
  498.       else
  499.         begin
  500.           if MaxY < 200 then
  501.             SetTextStyle(Font, HorizDir, CGASizes[Font])
  502.           else
  503.             SetTextStyle(Font, HorizDir, NormSizes[Font]);
  504.           Ch := '!';
  505.           repeat
  506.             OutText(Ch);
  507.             if (GetX + TextWidth('M')) > (x2-x1) then
  508.               MoveTo(2, GetY + TextHeight('M')+3);
  509.             Ch := Succ(Ch);
  510.           until (Ch >= #255);
  511.         end;
  512.     end; { with }
  513.     WaitToGo;
  514.   end; { for loop }
  515. end; { TextDump }
  516.  
  517. procedure LineToPlay;
  518. { Demonstrate MoveTo and LineTo commands }
  519. const
  520.   MaxPoints = 15;
  521. var
  522.   Points     : array[0..MaxPoints] of PointType;
  523.   ViewInfo   : ViewPortType;
  524.   I, J       : integer;
  525.   CenterX    : integer;   { The center point of the circle }
  526.   CenterY    : integer;
  527.   Radius     : word;
  528.   StepAngle  : word;
  529.   Xasp, Yasp : word;
  530.   Radians    : real;
  531.  
  532. function AdjAsp(Value : integer) : integer;
  533. { Adjust a value for the aspect ratio of the device }
  534. begin
  535.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  536. end; { AdjAsp }
  537.  
  538. begin
  539.   MainWindow('MoveTo, LineTo demonstration');
  540.   GetAspectRatio(Xasp, Yasp);
  541.   GetViewSettings(ViewInfo);
  542.   with ViewInfo do
  543.   begin
  544.     CenterX := (x2-x1) div 2;
  545.     CenterY := (y2-y1) div 2;
  546.     Radius := CenterY;
  547.     while (CenterY+AdjAsp(Radius)) < (y2-y1)-20 do
  548.       Inc(Radius);
  549.   end;
  550.   StepAngle := 360 div MaxPoints;
  551.   for I := 0 to MaxPoints - 1 do
  552.   begin
  553.     Radians := (StepAngle * I) * Pi / 180;
  554.     Points[I].X := CenterX + round(Cos(Radians) * Radius);
  555.     Points[I].Y := CenterY - AdjAsp(round(Sin(Radians) * Radius));
  556.   end;
  557.   Circle(CenterX, CenterY, Radius);
  558.   for I := 0 to MaxPoints - 1 do
  559.   begin
  560.     for J := I to MaxPoints - 1 do
  561.     begin
  562.       MoveTo(Points[I].X, Points[I].Y);
  563.       LineTo(Points[J].X, Points[J].Y);
  564.     end;
  565.   end;
  566.   WaitToGo;
  567. end; { LineToPlay }
  568.  
  569. procedure LineRelPlay;
  570. { Demonstrate MoveRel and LineRel commands }
  571. const
  572.   MaxPoints = 12;
  573. var
  574.   Poly     : array[1..MaxPoints] of PointType; { Stores a polygon for filling }
  575.   CurrPort : ViewPortType;
  576.  
  577. procedure DrawTesseract;
  578. { Draw a Tesseract on the screen with relative move and
  579.   line drawing commands, also create a polygon for filling }
  580. const
  581.   CheckerBoard : FillPatternType = (0, $10, $28, $44, $28, $10, 0, 0);
  582. var
  583.   X, Y, W, H   : integer;
  584.  
  585. begin
  586.   GetViewSettings(CurrPort);
  587.   with CurrPort do
  588.   begin
  589.     W := (x2-x1) div 9;
  590.     H := (y2-y1) div 8;
  591.     X := ((x2-x1) div 2) - round(2.5 * W);
  592.     Y := ((y2-y1) div 2) - (3 * H);
  593.  
  594.     { Border around viewport is outer part of polygon }
  595.     Poly[1].X := 0;     Poly[1].Y := 0;
  596.     Poly[2].X := x2-x1; Poly[2].Y := 0;
  597.     Poly[3].X := x2-x1; Poly[3].Y := y2-y1;
  598.     Poly[4].X := 0;     Poly[4].Y := y2-y1;
  599.     Poly[5].X := 0;     Poly[5].Y := 0;
  600.     MoveTo(X, Y);
  601.  
  602.     { Grab the whole in the polygon as we draw }
  603.     MoveRel(0, H);      Poly[6].X := GetX;  Poly[6].Y := GetY;
  604.     MoveRel(W, -H);     Poly[7].X := GetX;  Poly[7].Y := GetY;
  605.     MoveRel(4*W, 0);    Poly[8].X := GetX;  Poly[8].Y := GetY;
  606.     MoveRel(0, 5*H);    Poly[9].X := GetX;  Poly[9].Y := GetY;
  607.     MoveRel(-W, H);     Poly[10].X := GetX; Poly[10].Y := GetY;
  608.     MoveRel(-4*W, 0);   Poly[11].X := GetX; Poly[11].Y := GetY;
  609.     MoveRel(0, -5*H);   Poly[12].X := GetX; Poly[12].Y := GetY;
  610.  
  611.     { Fill the polygon with a user defined fill pattern }
  612.     SetFillPattern(CheckerBoard, MaxColor);
  613.     FillPoly(12, Poly);
  614.  
  615.     MoveRel(W, -H);
  616.     LineRel(0, 5*H);   LineRel(2*W, 0);    LineRel(0, -3*H);
  617.     LineRel(W, -H);    LineRel(0, 5*H);    MoveRel(0, -5*H);
  618.     LineRel(-2*W, 0);  LineRel(0, 3*H);    LineRel(-W, H);
  619.     MoveRel(W, -H);    LineRel(W, 0);      MoveRel(0, -2*H);
  620.     LineRel(-W, 0);
  621.  
  622.     { Flood fill the center }
  623.     FloodFill((x2-x1) div 2, (y2-y1) div 2, MaxColor);
  624.   end;
  625. end; { DrawTesseract }
  626.  
  627. begin
  628.   MainWindow('LineRel / MoveRel demonstration');
  629.   GetViewSettings(CurrPort);
  630.   with CurrPort do
  631.     { Move the viewport out 1 pixel from each end }
  632.     SetViewPort(x1-1, y1-1, x2+1, y2+1, ClipOn);
  633.   DrawTesseract;
  634.   WaitToGo;
  635. end; { LineRelPlay }
  636.  
  637. procedure PiePlay;
  638. { Demonstrate  PieSlice and GetAspectRatio commands }
  639. var
  640.   ViewInfo   : ViewPortType;
  641.   CenterX    : integer;
  642.   CenterY    : integer;
  643.   Radius     : word;
  644.   Xasp, Yasp : word;
  645.   X, Y       : integer;
  646.  
  647. function AdjAsp(Value : integer) : integer;
  648. { Adjust a value for the aspect ratio of the device }
  649. begin
  650.   AdjAsp := (LongInt(Value) * Xasp) div Yasp;
  651. end; { AdjAsp }
  652.  
  653. procedure GetTextCoords(AngleInDegrees, Radius : word; var X, Y : integer);
  654. { Get the coordinates of text for pie slice labels }
  655. var
  656.   Radians : real;
  657. begin
  658.   Radians := AngleInDegrees * Pi / 180;
  659.   X := round(Cos(Radians) * Radius);
  660.   Y := round(Sin(Radians) * Radius);
  661. end; { GetTextCoords }
  662.  
  663. begin
  664.   MainWindow('PieSlice / GetAspectRatio demonstration');
  665.   GetAspectRatio(Xasp, Yasp);
  666.   GetViewSettings(ViewInfo);
  667.   with ViewInfo do
  668.   begin
  669.     CenterX := (x2-x1) div 2;
  670.     CenterY := ((y2-y1) div 2) + 20;
  671.     Radius := (y2-y1) div 3;
  672.     while AdjAsp(Radius) < round((y2-y1) / 3.6) do
  673.       Inc(Radius);
  674.   end;
  675.   SetTextStyle(TriplexFont, HorizDir, 4);
  676.   SetTextJustify(CenterText, TopText);
  677.   OutTextXY(CenterX, 0, 'This is a pie chart!');
  678.  
  679.   SetTextStyle(TriplexFont, HorizDir, 3);
  680.  
  681.   SetFillStyle(SolidFill, RandColor);
  682.   PieSlice(CenterX+10, CenterY-AdjAsp(10), 0, 90, Radius);
  683.   GetTextCoords(45, Radius, X, Y);
  684.   SetTextJustify(LeftText, BottomText);
  685.   OutTextXY(CenterX+10+X+TextWidth('H'), CenterY-AdjAsp(10+Y), '25 %');
  686.  
  687.   SetFillStyle(HatchFill, RandColor);
  688.   PieSlice(CenterX, CenterY, 225, 360, Radius);
  689.   GetTextCoords(293, Radius, X, Y);
  690.   SetTextJustify(LeftText, TopText);
  691.   OutTextXY(CenterX+X+TextWidth('H'), CenterY-AdjAsp(Y), '37.5 %');
  692.  
  693.   SetFillStyle(InterleaveFill, RandColor);
  694.   PieSlice(CenterX-10, CenterY, 135, 225, Radius);
  695.   GetTextCoords(180, Radius, X, Y);
  696.   SetTextJustify(RightText, CenterText);
  697.   OutTextXY(CenterX-10+X-TextWidth('H'), CenterY-AdjAsp(Y), '25 %');
  698.  
  699.   SetFillStyle(WideDotFill, RandColor);
  700.   PieSlice(CenterX, CenterY, 90, 135, Radius);
  701.   GetTextCoords(112, Radius, X, Y);
  702.   SetTextJustify(RightText, BottomText);
  703.   OutTextXY(CenterX+X-TextWidth('H'), CenterY-AdjAsp(Y), '12.5 %');
  704.  
  705.   WaitToGo;
  706. end; { PiePlay }
  707.  
  708. procedure Bar3DPlay;
  709. { Demonstrate Bar3D command }
  710. const
  711.   NumBars   = 7;  { The number of bars drawn }
  712.   BarHeight : array[1..NumBars] of byte = (1, 3, 2, 5, 4, 2, 1);
  713.   YTicks    = 5;  { The number of tick marks on the Y axis }
  714. var
  715.   ViewInfo : ViewPortType;
  716.   H        : word;
  717.   XStep    : real;
  718.   YStep    : real;
  719.   I, J     : integer;
  720.   Depth    : word;
  721.   Color    : word;
  722. begin
  723.   MainWindow('Bar3D / Rectangle demonstration');
  724.   H := 3*TextHeight('M');
  725.   GetViewSettings(ViewInfo);
  726.   SetTextJustify(CenterText, TopText);
  727.   SetTextStyle(TriplexFont, HorizDir, 4);
  728.   OutTextXY(MaxX div 2, 6, 'These are 3D bars !');
  729.   SetTextStyle(DefaultFont, HorizDir, 1);
  730.   with ViewInfo do
  731.     SetViewPort(x1+50, y1+40, x2-50, y2-10, ClipOn);
  732.   GetViewSettings(ViewInfo);
  733.   with ViewInfo do
  734.   begin
  735.     Line(H, H, H, (y2-y1)-H);
  736.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  737.     YStep := ((y2-y1)-(2*H)) / YTicks;
  738.     XStep := ((x2-x1)-(2*H)) / NumBars;
  739.     J := (y2-y1)-H;
  740.     SetTextJustify(CenterText, CenterText);
  741.  
  742.     { Draw the Y axis and ticks marks }
  743.     for I := 0 to Yticks do
  744.     begin
  745.       Line(H div 2, J, H, J);
  746.       OutTextXY(0, J, Int2Str(I));
  747.       J := Round(J-Ystep);
  748.     end;
  749.  
  750.  
  751.     Depth := trunc(0.25 * XStep);    { Calculate depth of bar }
  752.  
  753.     { Draw X axis, bars, and tick marks }
  754.     SetTextJustify(CenterText, TopText);
  755.     J := H;
  756.     for I := 1 to Succ(NumBars) do
  757.     begin
  758.       SetColor(MaxColor);
  759.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  760.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I-1));
  761.       if I <> Succ(NumBars) then
  762.       begin
  763.         Color := RandColor;
  764.         SetFillStyle(I, Color);
  765.         SetColor(Color);
  766.         Bar3D(J, round((y2-y1-H)-(BarHeight[I] * Ystep)),
  767.                  round(J+Xstep-Depth), round((y2-y1)-H-1), Depth, TopOn);
  768.         J := Round(J+Xstep);
  769.       end;
  770.     end;
  771.  
  772.   end;
  773.   WaitToGo;
  774. end; { Bar3DPlay }
  775.  
  776. procedure BarPlay;
  777. { Demonstrate Bar command }
  778. const
  779.   NumBars   = 5;
  780.   BarHeight : array[1..NumBars] of byte = (1, 3, 5, 2, 4);
  781.   Styles    : array[1..NumBars] of byte = (1, 3, 10, 5, 9);
  782. var
  783.   ViewInfo  : ViewPortType;
  784.   BarNum    : word;
  785.   H         : word;
  786.   XStep     : real;
  787.   YStep     : real;
  788.   I, J      : integer;
  789.   Color     : word;
  790. begin
  791.   MainWindow('Bar / Rectangle demonstration');
  792.   H := 3*TextHeight('M');
  793.   GetViewSettings(ViewInfo);
  794.   SetTextJustify(CenterText, TopText);
  795.   SetTextStyle(TriplexFont, HorizDir, 4);
  796.   OutTextXY(MaxX div 2, 6, 'These are 2D bars !');
  797.   SetTextStyle(DefaultFont, HorizDir, 1);
  798.   with ViewInfo do
  799.     SetViewPort(x1+50, y1+30, x2-50, y2-10, ClipOn);
  800.   GetViewSettings(ViewInfo);
  801.   with ViewInfo do
  802.   begin
  803.     Line(H, H, H, (y2-y1)-H);
  804.     Line(H, (y2-y1)-H, (x2-x1)-H, (y2-y1)-H);
  805.     YStep := ((y2-y1)-(2*H)) / NumBars;
  806.     XStep := ((x2-x1)-(2*H)) / NumBars;
  807.     J := (y2-y1)-H;
  808.     SetTextJustify(CenterText, CenterText);
  809.  
  810.     { Draw Y axis with tick marks }
  811.     for I := 0 to NumBars do
  812.     begin
  813.       Line(H div 2, J, H, J);
  814.       OutTextXY(0, J, Int2Str(i));
  815.       J := Round(J-Ystep);
  816.     end;
  817.  
  818.     { Draw X axis, bars, and tick marks }
  819.     J := H;
  820.     SetTextJustify(CenterText, TopText);
  821.     for I := 1 to Succ(NumBars) do
  822.     begin
  823.       SetColor(MaxColor);
  824.       Line(J, (y2-y1)-H, J, (y2-y1-3)-(H div 2));
  825.       OutTextXY(J, (y2-y1)-(H div 2), Int2Str(I));
  826.       if I <> Succ(NumBars) then
  827.       begin
  828.         Color := RandColor;
  829.         SetFillStyle(Styles[I], Color);
  830.         SetColor(Color);
  831.         Bar(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  832.         Rectangle(J, round((y2-y1-H)-(BarHeight[I] * Ystep)), round(J+Xstep), (y2-y1)-H-1);
  833.       end;
  834.       J := Round(J+Xstep);
  835.     end;
  836.  
  837.   end;
  838.   WaitToGo;
  839. end; { BarPlay }
  840.  
  841. procedure CirclePlay;
  842. { Draw random circles on the screen }
  843. var
  844.   MaxRadius : word;
  845. begin
  846.   MainWindow('Circle demonstration');
  847.   StatusLine('Esc aborts or press a key');
  848.   MaxRadius := MaxY div 10;
  849.   SetLineStyle(SolidLn, 0, NormWidth);
  850.   repeat
  851.     SetColor(RandColor);
  852.     Circle(Random(MaxX), Random(MaxY), Random(MaxRadius));
  853.   until KeyPressed;
  854.   WaitToGo;
  855. end; { CirclePlay }
  856.  
  857.  
  858. procedure RandBarPlay;
  859. { Draw random bars on the screen }
  860. var
  861.   MaxWidth  : integer;
  862.   MaxHeight : integer;
  863.   ViewInfo  : ViewPortType;
  864.   Color     : word;
  865. begin
  866.   MainWindow('Random Bars');
  867.   StatusLine('Esc aborts or press a key');
  868.   GetViewSettings(ViewInfo);
  869.   with ViewInfo do
  870.   begin
  871.     MaxWidth := x2-x1;
  872.     MaxHeight := y2-y1;
  873.   end;
  874.   repeat
  875.     Color := RandColor;
  876.     SetColor(Color);
  877.     SetFillStyle(Random(CloseDotFill)+1, Color);
  878.     Bar3D(Random(MaxWidth), Random(MaxHeight),
  879.           Random(MaxWidth), Random(MaxHeight), 0, TopOff);
  880.   until KeyPressed;
  881.   WaitToGo;
  882. end; { RandBarPlay }
  883.  
  884. procedure ArcPlay;
  885. { Draw random arcs on the screen }
  886. var
  887.   MaxRadius : word;
  888.   EndAngle : word;
  889.   ArcInfo : ArcCoordsType;
  890. begin
  891.   MainWindow('Arc / GetArcCoords demonstration');
  892.   StatusLine('Esc aborts or press a key');
  893.   MaxRadius := MaxY div 10;
  894.   repeat
  895.     SetColor(RandColor);
  896.     EndAngle := Random(360);
  897.     SetLineStyle(SolidLn, 0, NormWidth);
  898.     Arc(Random(MaxX), Random(MaxY), Random(EndAngle), EndAngle, Random(MaxRadius));
  899.     GetArcCoords(ArcInfo);
  900.     with ArcInfo do
  901.     begin
  902.       Line(X, Y, XStart, YStart);
  903.       Line(X, Y, Xend, Yend);
  904.     end;
  905.   until KeyPressed;
  906.   WaitToGo;
  907. end; { ArcPlay }
  908.  
  909. procedure PutPixelPlay;
  910. { Demonstrate the PutPixel and GetPixel commands }
  911. const
  912.   Seed   = 1962; { A seed for the random number generator }
  913.   NumPts = 2000; { The number of pixels plotted }
  914.   Esc    = #27;
  915. var
  916.   I : word;
  917.   X, Y, Color : word;
  918.   XMax, YMax  : integer;
  919.   ViewInfo    : ViewPortType;
  920. begin
  921.   MainWindow('PutPixel / GetPixel demonstration');
  922.   StatusLine('Esc aborts or press a key...');
  923.  
  924.   GetViewSettings(ViewInfo);
  925.   with ViewInfo do
  926.   begin
  927.     XMax := (x2-x1-1);
  928.     YMax := (y2-y1-1);
  929.   end;
  930.  
  931.   while not KeyPressed do
  932.   begin
  933.     { Plot random pixels }
  934.     RandSeed := Seed;
  935.     I := 0;
  936.     while (not KeyPressed) and (I < NumPts) do
  937.     begin
  938.       Inc(I);
  939.         PutPixel(Random(XMax)+1, Random(YMax)+1, RandColor);
  940.     end;
  941.  
  942.     { Erase pixels }
  943.     RandSeed := Seed;
  944.     I := 0;
  945.     while (not KeyPressed) and (I < NumPts) do
  946.     begin
  947.       Inc(I);
  948.       X := Random(XMax)+1;
  949.       Y := Random(YMax)+1;
  950.       Color := GetPixel(X, Y);
  951.         if Color = RandColor then
  952.           PutPixel(X, Y, 0);
  953.      end;
  954.   end;
  955.   WaitToGo;
  956. end; { PutPixelPlay }
  957.  
  958. procedure PutImagePlay;
  959. { Demonstrate the GetImage and PutImage commands }
  960.  
  961. const
  962.   r  = 20;
  963.   StartX = 100;
  964.   StartY = 50;
  965.  
  966. var
  967.   CurPort : ViewPortType;
  968.  
  969. procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
  970. var
  971.   Step : integer;
  972. begin
  973.   Step := Random(2*r);
  974.   if Odd(Step) then
  975.     Step := -Step;
  976.   X := X + Step;
  977.   Step := Random(r);
  978.   if Odd(Step) then
  979.     Step := -Step;
  980.   Y := Y + Step;
  981.  
  982.   { Make saucer bounce off viewport walls }
  983.   with CurPort do
  984.   begin
  985.     if (x1 + X + Width - 1 > x2) then
  986.       X := x2-x1 - Width + 1
  987.     else
  988.       if (X < 0) then
  989.         X := 0;
  990.     if (y1 + Y + Height - 1 > y2) then
  991.       Y := y2-y1 - Height + 1
  992.     else
  993.       if (Y < 0) then
  994.         Y := 0;
  995.   end;
  996. end; { MoveSaucer }
  997.  
  998. var
  999.   Pausetime : word;
  1000.   Saucer    : pointer;
  1001.   X, Y      : integer;
  1002.   ulx, uly  : word;
  1003.   lrx, lry  : word;
  1004.   Size      : word;
  1005.   I         : word;
  1006. begin
  1007.   ClearDevice;
  1008.   FullPort;
  1009.  
  1010.   { PaintScreen }
  1011.   ClearDevice;
  1012.   MainWindow('GetImage / PutImage Demonstration');
  1013.   StatusLine('Esc aborts or press a key...');
  1014.   GetViewSettings(CurPort);
  1015.  
  1016.   { DrawSaucer }
  1017.   Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
  1018.   Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
  1019.   Line(StartX+7, StartY-6, StartX+10, StartY-12);
  1020.   Circle(StartX+10, StartY-12, 2);
  1021.   Line(StartX-7, StartY-6, StartX-10, StartY-12);
  1022.   Circle(StartX-10, StartY-12, 2);
  1023.   SetFillStyle(SolidFill, MaxColor);
  1024.   FloodFill(StartX+1, StartY+4, GetColor);
  1025.  
  1026.   { ReadSaucerImage }
  1027.   ulx := StartX-(r+1);
  1028.   uly := StartY-14;
  1029.   lrx := StartX+(r+1);
  1030.   lry := StartY+(r div 3)+3;
  1031.  
  1032.   Size := ImageSize(ulx, uly, lrx, lry);
  1033.   GetMem(Saucer, Size);
  1034.   GetImage(ulx, uly, lrx, lry, Saucer^);
  1035. {  PutImage(ulx, uly, Saucer^, XORput);               { erase image }
  1036.  
  1037.   { Plot some "stars" }
  1038.   for I := 1 to 1000 do
  1039.      PutPixel(Random(MaxX), Random(MaxY), RandColor);
  1040.   X := MaxX div 2;
  1041.   Y := MaxY div 2;
  1042.   PauseTime := 70;
  1043.  
  1044.   { Move the saucer around }
  1045.   repeat
  1046. {     PutImage(X, Y, Saucer^, XORput);                 { draw image }
  1047.      Delay(PauseTime);
  1048. {     PutImage(X, Y, Saucer^, XORput);                 { erase image }
  1049.      MoveSaucer(X, Y, lrx - ulx + 1, lry - uly + 1);  { width/height }
  1050.   until KeyPressed;
  1051.   FreeMem(Saucer, size);
  1052.   WaitToGo;
  1053. end; { PutImagePlay }
  1054.  
  1055. procedure PolyPlay;
  1056. { Draw random polygons with random fill styles on the screen }
  1057. const
  1058.   MaxPts = 5;
  1059. type
  1060.   PolygonType = array[1..MaxPts] of PointType;
  1061. var
  1062.   Poly : PolygonType;
  1063.   I, Color : word;
  1064. begin
  1065.   MainWindow('FillPoly demonstration');
  1066.   StatusLine('Esc aborts or press a key...');
  1067.   repeat
  1068.     Color := RandColor;
  1069.     SetFillStyle(Random(11)+1, Color);
  1070.     SetColor(Color);
  1071.     for I := 1 to MaxPts do
  1072.       with Poly[I] do
  1073.       begin
  1074.         X := Random(MaxX);
  1075.         Y := Random(MaxY);
  1076.       end;
  1077.     FillPoly(MaxPts, Poly);
  1078.   until KeyPressed;
  1079.   WaitToGo;
  1080. end; { PolyPlay }
  1081.  
  1082. procedure FillStylePlay;
  1083. { Display all of the predefined fill styles available }
  1084. var
  1085.   Style    : word;
  1086.   Width    : word;
  1087.   Height   : word;
  1088.   X, Y     : word;
  1089.   I, J     : word;
  1090.   ViewInfo : ViewPortType;
  1091.  
  1092. procedure DrawBox(X, Y : word);
  1093. begin
  1094.   SetFillStyle(Style, MaxColor);
  1095.   with ViewInfo do
  1096.     Bar(X, Y, X+Width, Y+Height);
  1097.   Rectangle(X, Y, X+Width, Y+Height);
  1098.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Style));
  1099.   Inc(Style);
  1100. end; { DrawBox }
  1101.  
  1102. begin
  1103.   MainWindow('Pre-defined fill styles');
  1104.   GetViewSettings(ViewInfo);
  1105.   with ViewInfo do
  1106.   begin
  1107.     Width := 2 * ((x2+1) div 13);
  1108.     Height := 2 * ((y2-10) div 10);
  1109.   end;
  1110.   X := Width div 2;
  1111.   Y := Height div 2;
  1112.   Style := 0;
  1113.   for J := 1 to 3 do
  1114.   begin
  1115.     for I := 1 to 4 do
  1116.     begin
  1117.       DrawBox(X, Y);
  1118.       Inc(X, (Width div 2) * 3);
  1119.     end;
  1120.     X := Width div 2;
  1121.     Inc(Y, (Height div 2) * 3);
  1122.   end;
  1123.   SetTextJustify(LeftText, TopText);
  1124.   WaitToGo;
  1125. end; { FillStylePlay }
  1126.  
  1127. procedure FillPatternPlay;
  1128. { Display some user defined fill patterns }
  1129. const
  1130.   Patterns : array[0..11] of FillPatternType = (
  1131.   ($AA, $55, $AA, $55, $AA, $55, $AA, $55),
  1132.   ($33, $33, $CC, $CC, $33, $33, $CC, $CC),
  1133.   ($F0, $F0, $F0, $F0, $F, $F, $F, $F),
  1134.   (0, $10, $28, $44, $28, $10, 0, 0),
  1135.   (0, $70, $20, $27, $25, $27, $4, $4),
  1136.   (0, 0, 0, $18, $18, 0, 0, 0),
  1137.   (0, 0, $3C, $3C, $3C, $3C, 0, 0),
  1138.   (0, $7E, $7E, $7E, $7E, $7E, $7E, 0),
  1139.   (0, 0, $22, $8, 0, $22, $1C, 0),
  1140.   ($FF, $7E, $3C, $18, $18, $3C, $7E, $FF),
  1141.   (0, $10, $10, $7C, $10, $10, 0, 0),
  1142.   (0, $42, $24, $18, $18, $24, $42, 0));
  1143. var
  1144.   Style    : word;
  1145.   Width    : word;
  1146.   Height   : word;
  1147.   X, Y     : word;
  1148.   I, J     : word;
  1149.   ViewInfo : ViewPortType;
  1150.  
  1151. procedure DrawBox(X, Y : word);
  1152. begin
  1153.   SetFillPattern(Patterns[Style], MaxColor);
  1154.   with ViewInfo do
  1155.     Bar(X, Y, X+Width, Y+Height);
  1156.   Rectangle(X, Y, X+Width, Y+Height);
  1157.   Inc(Style);
  1158. end; { DrawBox }
  1159.  
  1160. begin
  1161.   MainWindow('User defined fill styles');
  1162.   GetViewSettings(ViewInfo);
  1163.   with ViewInfo do
  1164.   begin
  1165.     Width := 2 * ((x2+1) div 13);
  1166.     Height := 2 * ((y2-10) div 10);
  1167.   end;
  1168.   X := Width div 2;
  1169.   Y := Height div 2;
  1170.   Style := 0;
  1171.   for J := 1 to 3 do
  1172.   begin
  1173.     for I := 1 to 4 do
  1174.     begin
  1175.       DrawBox(X, Y);
  1176.       Inc(X, (Width div 2) * 3);
  1177.     end;
  1178.     X := Width div 2;
  1179.     Inc(Y, (Height div 2) * 3);
  1180.   end;
  1181.   SetTextJustify(LeftText, TopText);
  1182.   WaitToGo;
  1183. end; { FillPatternPlay }
  1184.  
  1185. procedure ColorPlay;
  1186. { Display all of the colors available for the current driver and mode }
  1187. var
  1188.   Color    : word;
  1189.   Width    : word;
  1190.   Height   : word;
  1191.   X, Y     : word;
  1192.   I, J     : word;
  1193.   ViewInfo : ViewPortType;
  1194.  
  1195. procedure DrawBox(X, Y : word);
  1196. begin
  1197.   SetFillStyle(SolidFill, Color);
  1198.   SetColor(Color);
  1199.   with ViewInfo do
  1200.     Bar(X, Y, X+Width, Y+Height);
  1201.   Rectangle(X, Y, X+Width, Y+Height);
  1202.   Color := GetColor;
  1203.   if Color = 0 then
  1204.   begin
  1205.     SetColor(MaxColor);
  1206.     Rectangle(X, Y, X+Width, Y+Height);
  1207.   end;
  1208.   OutTextXY(X+(Width div 2), Y+Height+4, Int2Str(Color));
  1209.   Color := Succ(Color) mod (MaxColor + 1);
  1210. end; { DrawBox }
  1211.  
  1212. begin
  1213.   MainWindow('Color demonstration');
  1214.   Color := 1;
  1215.   GetViewSettings(ViewInfo);
  1216.   with ViewInfo do
  1217.   begin
  1218.     Width := 2 * ((x2+1) div 16);
  1219.     Height := 2 * ((y2-10) div 10);
  1220.   end;
  1221.   X := Width div 2;
  1222.   Y := Height div 2;
  1223.   for J := 1 to 3 do
  1224.   begin
  1225.     for I := 1 to 5 do
  1226.     begin
  1227.       DrawBox(X, Y);
  1228.       Inc(X, (Width div 2) * 3);
  1229.     end;
  1230.     X := Width div 2;
  1231.     Inc(Y, (Height div 2) * 3);
  1232.   end;
  1233.   WaitToGo;
  1234. end; { ColorPlay }
  1235.  
  1236. procedure PalettePlay;
  1237. { Demonstrate the use of the SetPalette command }
  1238. const
  1239.   XBars = 15;
  1240.   YBars = 10;
  1241. var
  1242.   I, J     : word;
  1243.   X, Y     : word;
  1244.   Color    : word;
  1245.   ViewInfo : ViewPortType;
  1246.   Width    : word;
  1247.   Height   : word;
  1248.   OldPal   : PaletteType;
  1249. begin
  1250.   GetPalette(OldPal);
  1251.   MainWindow('Palette demonstration');
  1252.   StatusLine('Press any key...');
  1253.   GetViewSettings(ViewInfo);
  1254.   with ViewInfo do
  1255.   begin
  1256.     Width := (x2-x1) div XBars;
  1257.     Height := (y2-y1) div YBars;
  1258.   end;
  1259.   X := 0; Y := 0;
  1260.   Color := 0;
  1261.   for J := 1 to YBars do
  1262.   begin
  1263.     for I := 1 to XBars do
  1264.     begin
  1265.       SetFillStyle(SolidFill, Color);
  1266.       Bar(X, Y, X+Width, Y+Height);
  1267.       Inc(X, Width+1);
  1268.       Inc(Color);
  1269.       Color := Color mod (MaxColor+1);
  1270.     end;
  1271.     X := 0;
  1272.     Inc(Y, Height+1);
  1273.   end;
  1274.   repeat
  1275.      SetPalette(Random(15 + 1), Random(65));
  1276.   until KeyPressed;
  1277.   SetAllPalette(OldPal);
  1278.   WaitToGo;
  1279. end; { PalettePlay }
  1280.  
  1281. procedure CrtModePlay;
  1282. { Demonstrate the use of RestoreCrtMode and SetGraphMode }
  1283. var
  1284.   ViewInfo : ViewPortType;
  1285.   Ch       : char;
  1286. begin
  1287.   MainWindow('SetGraphMode / RestoreCrtMode demo');
  1288.   GetViewSettings(ViewInfo);
  1289.   SetTextJustify(CenterText, CenterText);
  1290.   with ViewInfo do
  1291.   begin
  1292.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Now you are in graphics mode');
  1293.     StatusLine('Press any key for text mode...');
  1294.     repeat until KeyPressed;
  1295.     Ch := ReadKey;
  1296.     if ch = #0 then ch := readkey;    { trap function keys }
  1297.     RestoreCrtmode;
  1298.     Writeln('Now you are in text mode.');
  1299.     Write('Press any key to go back to graphics...');
  1300.     repeat until KeyPressed;
  1301.     Ch := ReadKey;
  1302.     if ch = #0 then ch := readkey;    { trap function keys }
  1303.     SetGraphMode(GetGraphMode);
  1304.     MainWindow('SetGraphMode / RestoreCrtMode demo');
  1305.     SetTextJustify(CenterText, CenterText);
  1306.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'Back in graphics mode...');
  1307.   end;
  1308.   WaitToGo;
  1309. end; { CrtModePlay }
  1310.  
  1311. procedure LineStylePlay;
  1312. { Demonstrate the predefined line styles available }
  1313. var
  1314.   Style    : word;
  1315.   Step     : word;
  1316.   X, Y     : word;
  1317.   ViewInfo : ViewPortType;
  1318.  
  1319. begin
  1320.   ClearDevice;
  1321.   DefaultColors;
  1322.   MainWindow('Pre-defined line styles');
  1323.   GetViewSettings(ViewInfo);
  1324.   with ViewInfo do
  1325.   begin
  1326.     X := 35;
  1327.     Y := 10;
  1328.     Step := (x2-x1) div 11;
  1329.     SetTextJustify(LeftText, TopText);
  1330.     OutTextXY(X, Y, 'NormWidth');
  1331.     SetTextJustify(CenterText, TopText);
  1332.     for Style := 0 to 3 do
  1333.     begin
  1334.       SetLineStyle(Style, 0, NormWidth);
  1335.       Line(X, Y+20, X, Y2-40);
  1336.       OutTextXY(X, Y2-30, Int2Str(Style));
  1337.       Inc(X, Step);
  1338.     end;
  1339.     Inc(X, 2*Step);
  1340.     SetTextJustify(LeftText, TopText);
  1341.     OutTextXY(X, Y, 'ThickWidth');
  1342.     SetTextJustify(CenterText, TopText);
  1343.     for Style := 0 to 3 do
  1344.     begin
  1345.       SetLineStyle(Style, 0, ThickWidth);
  1346.       Line(X, Y+20, X, Y2-40);
  1347.       OutTextXY(X, Y2-30, Int2Str(Style));
  1348.       Inc(X, Step);
  1349.     end;
  1350.   end;
  1351.   SetTextJustify(LeftText, TopText);
  1352.   WaitToGo;
  1353. end; { LineStylePlay }
  1354.  
  1355. procedure UserLineStylePlay;
  1356. { Demonstrate user defined line styles }
  1357. var
  1358.   Style    : word;
  1359.   X, Y, I  : word;
  1360.   ViewInfo : ViewPortType;
  1361. begin
  1362.   MainWindow('User defined line styles');
  1363.   GetViewSettings(ViewInfo);
  1364.   with ViewInfo do
  1365.   begin
  1366.     X := 4;
  1367.     Y := 10;
  1368.     Style := 0;
  1369.     I := 0;
  1370.     while X < X2-4 do
  1371.     begin
  1372.       {$B+}
  1373.       Style := Style or (1 shl (I mod 16));
  1374.       {$B-}
  1375.       SetLineStyle(UserBitLn, Style, NormWidth);
  1376.       Line(X, Y, X, (y2-y1)-Y);
  1377.       Inc(X, 5);
  1378.       Inc(I);
  1379.       if Style = 65535 then
  1380.       begin
  1381.         I := 0;
  1382.         Style := 0;
  1383.       end;
  1384.     end;
  1385.   end;
  1386.   WaitToGo;
  1387. end; { UserLineStylePlay }
  1388.  
  1389.  
  1390. procedure SayGoodbye;
  1391. { Say goodbye and then exit the program }
  1392. var
  1393.   ViewInfo : ViewPortType;
  1394. begin
  1395.   MainWindow('');
  1396.   GetViewSettings(ViewInfo);
  1397.   SetTextStyle(TriplexFont, HorizDir, 4);
  1398.   SetTextJustify(CenterText, CenterText);
  1399.   with ViewInfo do
  1400.     OutTextXY((x2-x1) div 2, (y2-y1) div 2, 'That''s all folks!');
  1401.   StatusLine('Press any key to quit...');
  1402.   repeat until KeyPressed;
  1403. end; { SayGoodbye }
  1404.  
  1405.  
  1406. PROCEDURE SelectMode;
  1407. VAR
  1408.     choice1,choice2     : CHAR;
  1409.    xsize,ysize            : WORD;
  1410. BEGIN
  1411.     (* Let's select a mode *)
  1412.     ClrScr;
  1413.     WriteLn('VESADEMO:');
  1414.     WriteLn('1. 256 colors');
  1415.     WriteLn('2. 32768 colors');
  1416.     WriteLn('3. 65536 colors');
  1417.     WriteLn('4. 16777216 colors');
  1418.     WriteLn('Q uit');
  1419.     WriteLn;
  1420.     Write('Your choice: ');
  1421.     REPEAT
  1422.         ReadLn(choice1);
  1423.       IF choice1 <> '1' THEN BEGIN
  1424.           WriteLn('Sorry !');
  1425.          WriteLn('This demo wasn''t written for more as 256 colors !');
  1426.          WriteLn('You would only get a limited impression of the Hi-& TrueColor modes...');
  1427.          WriteLn('Switching to 256 colors.');
  1428.          choice1 := '1';
  1429.       END;
  1430.     UNTIL choice1 IN ['1'..'4','q'];
  1431.     IF choice1 = 'q' THEN Halt;
  1432.  
  1433.     WriteLn;
  1434.     WriteLn;
  1435.     WriteLn('a. 320x200');
  1436.     WriteLn('b. 640x480');
  1437.     WriteLn('c. 800x600');
  1438.     WriteLn('d. 1024x768');
  1439.     WriteLn('e. 1280x1024');
  1440.     WriteLn('Q uit');
  1441.     WriteLn;
  1442.     Write('Your choice: ');
  1443.     REPEAT
  1444.         ReadLn(choice2);
  1445.     UNTIL choice2 IN ['a'..'e','q'];
  1446.     IF choice2 = 'q' THEN Halt;
  1447.  
  1448.     CASE choice2 OF
  1449.         'a' : BEGIN
  1450.             xsize := 320;
  1451.             ysize := 200;
  1452.         END;
  1453.         'b' : BEGIN
  1454.             xsize := 640;
  1455.             ysize := 480;
  1456.         END;
  1457.         'c' : BEGIN
  1458.             xsize := 800;
  1459.             ysize := 600;
  1460.         END;
  1461.         'd' : BEGIN
  1462.             xsize := 1024;
  1463.             ysize := 768;
  1464.         END;
  1465.         'e' : BEGIN
  1466.             xsize := 1280;
  1467.             ysize := 1024;
  1468.         END;
  1469.     END;
  1470.     CASE choice1 OF
  1471.         '1' : mode := FindVesaMode(xsize,ysize,8);
  1472.         '2' : mode := FindVesaMode(xsize,ysize,15);
  1473.         '3' : mode := FindVesaMode(xsize,ysize,16);
  1474.         '4' : mode := FindVesaMode(xsize,ysize,24);
  1475.     END;
  1476.     IF mode = 0 THEN BEGIN
  1477.         WriteLn('No such mode could be found !');
  1478.         WriteLn('Switching to to 320x200.');
  1479.         ReadKey;
  1480.         mode := V320x200x256;
  1481.     END;
  1482. END;
  1483.  
  1484. begin { program body }
  1485.   SelectMode;
  1486.   Initialize;
  1487.   ReportStatus;
  1488.  
  1489. {  AspectRatioPlay; }
  1490.   FillEllipsePlay;
  1491.   SectorPlay;
  1492.   WriteModePlay;
  1493.  
  1494.   ColorPlay;
  1495.   { PalettePlay only intended to work on these drivers: }
  1496.   if (GraphDriver = EGA) or
  1497.       (GraphDriver = EGA64) or
  1498.       (GraphDriver = VGA) then
  1499.      PalettePlay;
  1500.   PutPixelPlay;
  1501. {  PutImagePlay; }
  1502.   RandBarPlay;
  1503.   BarPlay;
  1504.   Bar3DPlay;
  1505.   ArcPlay;
  1506.   CirclePlay;
  1507.   PiePlay;
  1508.   LineToPlay;
  1509.   LineRelPlay;
  1510. {  LineStylePlay; }
  1511. {  UserLineStylePlay; }
  1512.   TextDump;
  1513.   TextPlay;
  1514.   CrtModePlay;
  1515.   FillStylePlay;
  1516.   FillPatternPlay;
  1517.   PolyPlay;
  1518.   SayGoodbye;
  1519. {  CloseGraph; }
  1520.   CloseVesa;
  1521. end.
  1522.